home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / ICON_8 / ICONT_FO / LCODE.C < prev    next >
Text File  |  1990-03-02  |  30KB  |  1,191 lines
  1. /*
  2.  * lcode.c -- linker routines to parse .u1 files and produce icode.
  3.  */
  4.  
  5. #include <math.h>
  6. #include "::h:config.h"
  7. #include "tproto.h"
  8. #include "globals.h"
  9. #include "opcode.h"
  10. #include "link.h"
  11. #include "general.h"
  12. #include "::h:keyword.h"
  13. #include "::h:version.h"
  14. #include "::h:header.h"
  15.  
  16. /*
  17.  * Prototypes.
  18.  */
  19.  
  20. hidden novalue    backpatch    Params((int lab));
  21. hidden novalue    clearlab    Params((noargs));
  22. hidden novalue    flushcode    Params((noargs));
  23. hidden novalue    intout        Params((int oint));
  24. hidden novalue    lemit        Params((int op,char *name));
  25. hidden novalue    lemitcon    Params((int k));
  26. hidden novalue    lemiteven    Params((noargs));
  27. hidden novalue    lemitin        Params((int op,word offset,int n,char *name));
  28. hidden novalue    lemitint    Params((int op,long i,char *name));
  29. hidden novalue    lemitl        Params((int op,int lab,char *name));
  30. hidden novalue    lemitn        Params((int op,word n,char *name));
  31. hidden novalue    lemitproc
  32.    Params((char *name,int nargs,int ndyn,int nstat, int fstat));
  33. hidden novalue    lemitr        Params((int op,word loc,char *name));
  34. hidden novalue    outblock    Params((char *addr,int count));
  35. hidden novalue    wordout        Params((word oword));
  36.  
  37. #ifdef DeBugLinker
  38. hidden novalue    dumpblock    Params((char *addr,int count));
  39. #endif                    /* DeBugLinker */
  40.  
  41. #if AMIGA
  42. #include <fcntl.h>
  43. #endif                    /* AMIGA */
  44.  
  45. #ifndef MaxHeader
  46. #define MaxHeader MaxHdr
  47. #endif                    /* MaxHeader */
  48.  
  49. word pc = 0;        /* simulated program counter */
  50.  
  51. #define outword(n)    wordout((word)(n))
  52. #define outop(n)    intout((int)(n))
  53. #define CodeCheck(n) if ((long)codep + n > (long)((long)codeb + maxcode))\
  54.                      quit("out of code buffer space")
  55.  
  56. /*
  57.  * gencode - read .u1 file, resolve variable references, and generate icode.
  58.  *  Basic process is to read each line in the file and take some action
  59.  *  as dictated by the opcode.    This action sometimes involves parsing
  60.  *  of arguments and usually culminates in the call of the appropriate
  61.  *  lemit* routine.
  62.  */
  63. novalue gencode()
  64.    {
  65.    register int op, k, lab;
  66.    int j, nargs, flags, implicit;
  67.    char *id, *name, *procname;
  68.    struct centry *cp;
  69.    struct gentry *gp;
  70.    struct fentry *fp;
  71.    union xval gg;
  72.  
  73.    while ((op = getopc(&name)) != EOF) {
  74.       switch (op) {
  75.  
  76.          /* Ternary operators. */
  77.  
  78.          case Op_Toby:
  79.          case Op_Sect:
  80.  
  81.          /* Binary operators. */
  82.  
  83.          case Op_Asgn:
  84.          case Op_Cat:
  85.          case Op_Diff:
  86.          case Op_Div:
  87.          case Op_Eqv:
  88.          case Op_Inter:
  89.          case Op_Lconcat:
  90.          case Op_Lexeq:
  91.          case Op_Lexge:
  92.          case Op_Lexgt:
  93.          case Op_Lexle:
  94.          case Op_Lexlt:
  95.          case Op_Lexne:
  96.          case Op_Minus:
  97.          case Op_Mod:
  98.          case Op_Mult:
  99.          case Op_Neqv:
  100.          case Op_Numeq:
  101.          case Op_Numge:
  102.          case Op_Numgt:
  103.          case Op_Numle:
  104.          case Op_Numlt:
  105.          case Op_Numne:
  106.          case Op_Plus:
  107.          case Op_Power:
  108.          case Op_Rasgn:
  109.          case Op_Rswap:
  110.          case Op_Subsc:
  111.          case Op_Swap:
  112.          case Op_Unions:
  113.  
  114.          /* Unary operators. */
  115.  
  116.          case Op_Bang:
  117.          case Op_Compl:
  118.          case Op_Neg:
  119.          case Op_Nonnull:
  120.          case Op_Null:
  121.          case Op_Number:
  122.          case Op_Random:
  123.          case Op_Refresh:
  124.          case Op_Size:
  125.          case Op_Tabmat:
  126.          case Op_Value:
  127.  
  128.          /* Instructions. */
  129.  
  130.          case Op_Bscan:
  131.          case Op_Ccase:
  132.          case Op_Coact:
  133.          case Op_Cofail:
  134.          case Op_Coret:
  135.          case Op_Dup:
  136.          case Op_Efail:
  137.          case Op_Eret:
  138.          case Op_Escan:
  139.          case Op_Esusp:
  140.          case Op_Limit:
  141.          case Op_Lsusp:
  142.          case Op_Pfail:
  143.          case Op_Pnull:
  144.          case Op_Pop:
  145.          case Op_Pret:
  146.          case Op_Psusp:
  147.          case Op_Push1:
  148.          case Op_Pushn1:
  149.          case Op_Sdup:
  150.             newline();
  151.             lemit(op, name);
  152.             break;
  153.  
  154.          case Op_Chfail:
  155.          case Op_Create:
  156.          case Op_Goto:
  157.          case Op_Init:
  158.             lab = getlab();
  159.             newline();
  160.             lemitl(op, lab, name);
  161.             break;
  162.  
  163.          case Op_Cset:
  164.          case Op_Real:
  165.             k = getdec();
  166.             newline();
  167.             lemitr(op, lctable[k].c_pc, name);
  168.             break;
  169.  
  170.          case Op_Field:
  171.             id = getid();
  172.             newline();
  173.             fp = flocate(id);
  174.             if (fp == NULL) {
  175.                lfatal(id, "invalid field name");
  176.                break;
  177.                }
  178.             lemitn(op, (word)(fp->f_fid-1), name);
  179.             break;
  180.  
  181.  
  182.          case Op_Int: {
  183.             long i;
  184.             k = getdec();
  185.             newline();
  186.             cp = &lctable[k];
  187.             /*
  188.              * Check to see if a large integers has been converted to a string.
  189.              *  If so, generate the code for +s.
  190.              */
  191.             if (cp->c_flag & F_StrLit) {
  192.                id = cp->c_val.sval;
  193.                lemit(Op_Pnull,"pnull");
  194.                lemitin(Op_Str, (word)(id-lsspace), cp->c_length, "str");
  195.                lemit(Op_Number,"number");
  196.                break;
  197.                }
  198.             i = (long)cp->c_val.ival;
  199.             lemitint(op, i, name);
  200.             break;
  201.             }
  202.  
  203.  
  204.          case Op_Invoke:
  205.             k = getdec();
  206.             newline();
  207.             if (k == -1)
  208.                lemit(Op_Apply,"apply");
  209.             else
  210.                lemitn(op, (word)k, name);
  211.             break;
  212.  
  213.          case Op_Keywd:
  214.             k = getdec();
  215.             newline();
  216.             switch (k) {
  217.                case K_FAIL:
  218.                   lemit(Op_Efail,"efail");
  219.                   break;
  220.                case K_NULL:
  221.                   lemit(Op_Pnull,"pnull");
  222.                   break;
  223.                default:
  224.                lemitn(op, (word)k, name);
  225.             }
  226.             break;
  227.  
  228.          case Op_Llist:
  229.             k = getdec();
  230.             newline();
  231.             lemitn(op, (word)k, name);
  232.             break;
  233.  
  234.          case Op_Lab:
  235.             lab = getlab();
  236.             newline();
  237.  
  238. #ifdef DeBugLinker
  239.             if (Dflag)
  240.                fprintf(dbgfile, "L%d:\n", lab);
  241. #endif                    /* DeBugLinker */
  242.             backpatch(lab);
  243.             break;
  244.  
  245.          case Op_Line:
  246.             if (lnfree >= &lntable[nsize])
  247.                quit("out of line number table space");
  248.             lnfree->ipc = pc;
  249.             lineno = getdec();
  250.             lnfree->line = lineno;
  251.             lnfree++;
  252.  
  253. #ifdef EvalTrace
  254.             lemitn(op, (word)lineno, name);
  255. #endif                    /* EvalTrace */
  256.             
  257.             newline();
  258.  
  259.  
  260. #ifdef LineCodes
  261.             lemit(Op_Noop,"noop");
  262. #endif                    /* LineCodes */
  263.  
  264.             break;
  265.  
  266. #ifdef EvalTrace
  267.          case Op_Colm:
  268.             colmno = getdec();
  269.             lemitn(op, (word)colmno, name);
  270.             break;
  271. #endif                    /* EvalTrace */
  272.  
  273.          case Op_Mark:
  274.             lab = getlab();
  275.             newline();
  276.             lemitl(op, lab, name);
  277.             break;
  278.  
  279.          case Op_Mark0:
  280.             lemit(op, name);
  281.             break;
  282.  
  283.          case Op_Str:
  284.             k = getdec();
  285.             newline();
  286.             cp = &lctable[k];
  287.             id = cp->c_val.sval;
  288.             lemitin(op, (word)(id-lsspace), cp->c_length, name);
  289.             break;
  290.     
  291.          case Op_Tally:
  292.             k = getdec();
  293.             newline();
  294.             lemitn(op, (word)k, name);
  295.             break;
  296.  
  297.          case Op_Unmark:
  298.             lemit(Op_Unmark, name);
  299.             break;
  300.  
  301.          case Op_Var:
  302.             k = getdec();
  303.             newline();
  304.             flags = lltable[k].l_flag;
  305.             if (flags & F_Global)
  306.                lemitn(Op_Global, (word)(lltable[k].l_val.global-lgtable),
  307.                   "global");
  308.             else if (flags & F_Static)
  309.                lemitn(Op_Static, (word)(lltable[k].l_val.staticid-1), "static");
  310.             else if (flags & F_Argument)
  311.                lemitn(Op_Arg, (word)(lltable[k].l_val.offset-1), "arg");
  312.             else
  313.                lemitn(Op_Local, (word)(lltable[k].l_val.offset-1), "local");
  314.             break;
  315.  
  316.          /* Declarations. */
  317.  
  318.          case Op_Proc:
  319.             procname = getid();
  320.             newline();
  321.             locinit();
  322.             clearlab();
  323.             lineno = 0;
  324.             gp = glocate(procname);
  325.             implicit = gp->g_flag & F_ImpError;
  326.             nargs = gp->g_nargs;
  327.             lemiteven();
  328.             break;
  329.  
  330.          case Op_Local:
  331.             k = getdec();
  332.             flags = getoct();
  333.             id = getid();
  334.             putlocal(k, id, flags, implicit, procname);
  335.             break;
  336.  
  337.          case Op_Con:
  338.             k = getdec();
  339.             flags = getoct();
  340.             if (flags & F_IntLit) {
  341.                {
  342.                long m;
  343.                char *s;
  344.  
  345.                j = getdec();        /* number of characters in integer */
  346.                m = getint(j,&s);    /* convert if possible */
  347.                if (m < 0) {         /* negative indicates integer too big */
  348.                   gg.sval = s;        /* convert to a string */
  349.                   putconst(k, F_StrLit, j, pc, &gg);
  350.                   }
  351.                else {            /* integers is small enough */
  352.                   gg.ival = m;
  353.                   putconst(k, flags, 0, pc, &gg);
  354.                   }
  355.                }
  356.                }
  357.             else if (flags & F_RealLit) {
  358.                gg.rval = getreal();
  359.                putconst(k, flags, 0, pc, &gg);
  360.                }
  361.             else if (flags & F_StrLit) {
  362.                j = getdec();
  363.                gg.sval = getstrlit(j);
  364.                putconst(k, flags, j, pc, &gg);
  365.                }
  366.             else if (flags & F_CsetLit) {
  367.                j = getdec();
  368.                gg.sval = getstrlit(j);
  369.                putconst(k, flags, j, pc, &gg);
  370.                }
  371.             else
  372.                fprintf(stderr, "gencode: illegal constant\n");
  373.             newline();
  374.             lemitcon(k);
  375.             break;
  376.  
  377.          case Op_Filen:
  378.             if (fnmfree >= &fnmtbl[fnmsize])
  379.                quit("out of file name table space");
  380.             fnmfree->ipc = pc;
  381.             fnmfree->fname = getrest() - lsspace;
  382. /*          fnmfree->fname = getid() - lsspace; */
  383.             fnmfree++;
  384.             newline();
  385.             break;
  386.  
  387.          case Op_Declend:
  388.             newline();
  389.             gp->g_pc = pc;
  390.             lemitproc(procname, nargs, dynoff, lstatics-static1, static1);
  391.             break;
  392.  
  393.          case Op_End:
  394.             newline();
  395.             flushcode();
  396.             break;
  397.  
  398.          default:
  399.             fprintf(stderr, "gencode: illegal opcode(%d): %s\n", op, name);
  400.             newline();
  401.          }
  402.       }
  403.    }
  404.  
  405. /*
  406.  *  lemit - emit opcode.
  407.  *  lemitl - emit opcode with reference to program label.
  408.  *    for a description of the chaining and backpatching for labels.
  409.  *  lemitn - emit opcode with integer argument.
  410.  *  lemitr - emit opcode with pc-relative reference.
  411.  *  lemitin - emit opcode with reference to identifier table & integer argument.
  412.  *  lemitint - emit word opcode with integer argument.
  413.  *  lemiteven - emit null bytes to bring pc to word boundary.
  414.  *  lemitcon - emit constant table entry.
  415.  *  lemitproc - emit procedure block.
  416.  *
  417.  * The lemit* routines call out* routines to effect the "outputting" of icode.
  418.  *  Note that the majority of the code for the lemit* routines is for debugging
  419.  *  purposes.
  420.  */
  421. static novalue lemit(op, name)
  422. int op;
  423. char *name;
  424.    {
  425.  
  426. #ifdef DeBugLinker
  427.    if (Dflag)
  428.       fprintf(dbgfile, "%ld:\t%d\t\t\t\t# %s\n", (long)pc, op, name);
  429. #else                    /* DeBugLinker */
  430. #if MACINTOSH && MPW
  431. /* #pragma unused(name)    */
  432. #endif                    /* MACINTOSH && MPW */
  433. #endif                    /* DeBugLinker */
  434.  
  435.    outop(op);
  436.    }
  437.  
  438. static novalue lemitl(op, lab, name)
  439. int op, lab;
  440. char *name;
  441.    {
  442.  
  443. #ifdef DeBugLinker
  444.    if (Dflag)
  445.       fprintf(dbgfile, "%ld:\t%d\tL%d\t\t\t# %s\n", (long)pc, op, lab, name);
  446. #else                    /* DeBugLinker */
  447. #if MACINTOSH && MPW
  448. /* #pragma unused(name)    */
  449. #endif                    /* MACINTOSH && MPW */
  450. #endif                    /* DeBugLinker */
  451.  
  452.    if (lab >= maxlabels)
  453.       quit("out of label space");
  454.    outop(op);
  455.    if (labels[lab] <= 0) {        /* forward reference */
  456.       outword(labels[lab]);
  457.       labels[lab] = WordSize - pc;    /* add to front of reference chain */
  458.       }
  459.    else                    /* output relative offset */
  460.       outword(labels[lab] - (pc + WordSize));
  461.    }
  462.  
  463. static novalue lemitn(op, n, name)
  464. int op;
  465. word n;
  466. char *name;
  467.    {
  468.  
  469. #ifdef DeBugLinker
  470.    if (Dflag)
  471.       fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)n,
  472.          name);
  473. #else                    /* DeBugLinker */
  474. #if MACINTOSH && MPW
  475. /* #pragma unused(name) */
  476. #endif                    /* MACINTOSH && MPW */
  477. #endif                    /* DeBugLinker */
  478.  
  479.    outop(op);
  480.    outword(n);
  481.    }
  482.  
  483.  
  484. static novalue lemitr(op, loc, name)
  485. int op;
  486. word loc;
  487. char *name;
  488.    {
  489.    loc -= pc + ((IntBits/ByteBits) + WordSize);
  490.  
  491. #ifdef DeBugLinker
  492.    if (Dflag) {
  493.       if (loc >= 0)
  494.          fprintf(dbgfile, "%ld:\t%d\t*+%ld\t\t\t# %s\n",(long) pc, op,
  495.             (long)loc, name);
  496.       else
  497.          fprintf(dbgfile, "%ld:\t%d\t*-%ld\t\t\t# %s\n",(long) pc, op,
  498.             (long)-loc, name);
  499.       }
  500. #else                    /* DeBugLinker */
  501. #if MACINTOSH && MPW
  502. /* #pragma unused(name) */
  503. #endif                    /* MACINTOSH && MPW */
  504. #endif                    /* DeBugLinker */
  505.  
  506.    outop(op);
  507.    outword(loc);
  508.    }
  509.  
  510. static novalue lemitin(op, offset, n, name)
  511. int op, n;
  512. word offset;
  513. char *name;
  514.    {
  515.  
  516. #ifdef DeBugLinker
  517.    if (Dflag)
  518.       fprintf(dbgfile, "%ld:\t%d\t%d,I+%ld\t\t\t# %s\n", (long)pc, op, n,
  519.          (long)offset, name);
  520. #else                    /* DeBugLinker */
  521. #if MACINTOSH && MPW
  522. /* #pragma unused(name) */
  523. #endif                    /* MACINTOSH && MPW */
  524. #endif                    /* DeBugLinker */
  525.  
  526.    outop(op);
  527.    outword(n);
  528.    outword(offset);
  529.    }
  530.  
  531. /*
  532.  * lemitint can have some pitfalls.  outword is used to output the
  533.  *  integer and this is picked up in the interpreter as the second
  534.  *  word of a short integer.  The integer value output must be
  535.  *  the same size as what the interpreter expects.  See op_int and op_intx
  536.  *  in interp.s
  537.  */
  538. static novalue lemitint(op, i, name)
  539. int op;
  540. long i;
  541. char *name;
  542.    {
  543.  
  544. #ifdef DeBugLinker
  545.    if (Dflag)
  546.       fprintf(dbgfile,"%ld:\t%d\t%ld\t\t\t# %s\n",(long)pc,op,(long)i,name);
  547. #else                    /* DeBugLinker */
  548. #if MACINTOSH && MPW
  549. /* #pragma unused(name) */
  550. #endif                    /* MACINTOSH && MPW */
  551. #endif                    /* DeBugLinker */
  552.  
  553.    outop(op);
  554.    outword(i);
  555.    }
  556.  
  557. static novalue lemiteven()
  558.    {
  559.    word x = 0;
  560.    register int len;
  561.  
  562.    if (len = pc % (IntBits/ByteBits))
  563.       outblock((char *)x, (IntBits/ByteBits) - len);
  564.    }
  565.  
  566. static novalue lemitcon(k)
  567. register int k;
  568.    {
  569.    register int i, j;
  570.    register char *s;
  571.    int csbuf[CsetSize];
  572.    union {
  573.       char ovly[1];  /* Array used to overlay l and f on a bytewise basis. */
  574.       long l;
  575.       double f;
  576.       } x;
  577.  
  578.    if (lctable[k].c_flag & F_RealLit) {
  579.  
  580. #ifdef Double
  581. /* access real values one word at a time */
  582.       {  int *rp, *rq;
  583.          rp = (int *) &(x.f);
  584.          rq = (int *) &(lctable[k].c_val.rval);
  585.          *rp++ = *rq++;
  586.          *rp    = *rq;
  587.       }
  588. #else                    /* Double */
  589.       x.f = lctable[k].c_val.rval;
  590. #endif                    /* Double */
  591.  
  592. #ifdef DeBugLinker
  593.       if (Dflag) {
  594.          fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Real);
  595.          dumpblock(x.ovly,sizeof(double));
  596.          fprintf(dbgfile, "\t\t\t( %g )\n",x.f);
  597.          }
  598. #endif                    /* DeBugLinker */
  599.  
  600.       outword(T_Real);
  601.  
  602. #ifdef Double
  603. /* fill out real block with an empty word */
  604.       outword(0);
  605. #endif                    /* Double */
  606.  
  607.       outblock(x.ovly,sizeof(double));
  608.       }
  609.    else if (lctable[k].c_flag & F_CsetLit) {
  610.       for (i = 0; i < CsetSize; i++)
  611.          csbuf[i] = 0;
  612.       s = lctable[k].c_val.sval;
  613.       i = lctable[k].c_length;
  614.       while (i--) {
  615.          Setb(ToAscii(*s), csbuf);
  616.          s++;
  617.          }
  618.       j = 0;
  619.       for (i = 0; i < 256; i++) {
  620.          if (Testb(i, csbuf))
  621.            j++;
  622.          }
  623.  
  624. #ifdef DeBugLinker
  625.       if (Dflag) {
  626.          fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Cset);
  627.          fprintf(dbgfile, "\t%d\n",j);
  628.          fprintf(dbgfile,(char *)csbuf,sizeof(csbuf));
  629.          }
  630. #endif                    /* DeBugLinker */
  631.  
  632.       outword(T_Cset);
  633.       outword(j);           /* cset size */
  634.       outblock((char *)csbuf,sizeof(csbuf));
  635.  
  636. #ifdef DeBugLinker
  637.       if (Dflag)
  638.          dumpblock((char *)csbuf,CsetSize);
  639. #endif                    /* DeBugLinker */
  640.  
  641.       }
  642.    }
  643.  
  644. static novalue lemitproc(name, nargs, ndyn, nstat, fstat)
  645. char *name;
  646. int nargs, ndyn, nstat, fstat;
  647.    {
  648.    register int i;
  649.    register char *p;
  650.    int size;
  651.    /*
  652.     * FncBlockSize = sizeof(BasicFncBlock) +
  653.     *  sizeof(descrip)*(# of args + # of dynamics + # of statics).
  654.     */
  655.    size = (9*WordSize) + (2*WordSize) * (abs(nargs)+ndyn+nstat);
  656.  
  657. #ifdef DeBugLinker
  658.    if (Dflag) {
  659.       fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Proc); /* type code */
  660.       fprintf(dbgfile, "\t%d\n", size);            /* size of block */
  661.       fprintf(dbgfile, "\tZ+%ld\n",(long)(pc+size));    /* entry point */
  662.       fprintf(dbgfile, "\t%d\n", nargs);        /* # arguments */
  663.       fprintf(dbgfile, "\t%d\n", ndyn);            /* # dynamic locals */
  664.       fprintf(dbgfile, "\t%d\n", nstat);        /* # static locals */
  665.       fprintf(dbgfile, "\t%d\n", fstat);        /* first static */
  666.       fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n",    /* name of procedure */
  667.          (int)strlen(name), (long)(name-lsspace), name);
  668.       }
  669. #endif                    /* DeBugLinker */
  670.  
  671.    outword(T_Proc);
  672.    outword(size);
  673.    outword(pc + size - 2*WordSize); /* Have to allow for the two words
  674.                      that we've already output. */
  675.    outword(nargs);
  676.    outword(ndyn);
  677.    outword(nstat);
  678.    outword(fstat);
  679.    outword(strlen(name));
  680.    outword(name - lsspace);
  681.  
  682.    /*
  683.     * Output string descriptors for argument names by looping through
  684.     *  all locals, and picking out those with F_Argument set.
  685.     */
  686.    for (i = 0; i <= nlocal; i++) {
  687.       if (lltable[i].l_flag & F_Argument) {
  688.          p = lltable[i].l_name;
  689.  
  690. #ifdef DeBugLinker
  691.          if (Dflag)
  692.             fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(p),
  693.                (long)(p-lsspace), p);
  694. #endif                    /* DeBugLinker */
  695.  
  696.          outword(strlen(p));
  697.          outword(p - lsspace);
  698.          }
  699.       }
  700.  
  701.    /*
  702.     * Output string descriptors for local variable names.
  703.     */
  704.    for (i = 0; i <= nlocal; i++) {
  705.       if (lltable[i].l_flag & F_Dynamic) {
  706.          p = lltable[i].l_name;
  707.  
  708. #ifdef DeBugLinker
  709.          if (Dflag)
  710.             fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(p),
  711.                (long)(p-lsspace), p);
  712. #endif                    /* DeBugLinker */
  713.  
  714.          outword(strlen(p));
  715.          outword(p - lsspace);
  716.          }
  717.       }
  718.  
  719.    /*
  720.     * Output string descriptors for local variable names.
  721.     */
  722.    for (i = 0; i <= nlocal; i++) {
  723.       if (lltable[i].l_flag & F_Static) {
  724.          p = lltable[i].l_name;
  725.  
  726. #ifdef DeBugLinker
  727.          if (Dflag)
  728.             fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(p),
  729.                (long)(p-lsspace), p);
  730. #endif                    /* DeBugLinker */
  731.  
  732.          outword(strlen(p));
  733.          outword(p - lsspace);
  734.          }
  735.       }
  736.    }
  737.  
  738. /*
  739.  * gentables - generate interpreter code for global, static,
  740.  *  identifier, and record tables, and built-in procedure blocks.
  741.  */
  742.  
  743. novalue gentables()
  744.    {
  745.    register int i;
  746.    register char *s;
  747.    register struct gentry *gp;
  748.    struct fentry *fp;
  749.    struct rentry *rp;
  750.    struct header hdr;
  751.  
  752. #if MVS
  753.    FILE *toutfile;        /* temporary file for icode output */
  754. #endif                    /* MVS */
  755.  
  756.    lemiteven();
  757.  
  758.    /*
  759.     * Output record constructor procedure blocks.
  760.     */
  761.    hdr.records = pc;
  762.  
  763. #ifdef DeBugLinker
  764.    if (Dflag)
  765.       fprintf(dbgfile, "%ld:\t%d\t\t\t\t# record blocks\n",(long)pc, nrecords);
  766. #endif                    /* DeBugLinker */
  767.  
  768.    outword(nrecords);
  769.    for (gp = lgtable; gp < lgfree; gp++) {
  770.       if (gp->g_flag & (F_Record & ~F_Global)) {
  771.          s = gp->g_name;
  772.          gp->g_pc = pc;
  773.  
  774. #ifdef DeBugLinker
  775.          if (Dflag) {
  776.             fprintf(dbgfile, "%ld:\n", pc);
  777.             fprintf(dbgfile, "\t%d\n", T_Proc);
  778.             fprintf(dbgfile, "\t%d\n", RkBlkSize);
  779.             fprintf(dbgfile, "\t_mkrec\n");
  780.             fprintf(dbgfile, "\t%d\n", gp->g_nargs);
  781.             fprintf(dbgfile, "\t-2\n");
  782.             fprintf(dbgfile, "\t%d\n", gp->g_procid);
  783.             fprintf(dbgfile, "\t1\n");
  784.             fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(s),
  785.                (long)(s-lsspace), s);
  786.             }
  787.  
  788. #endif                    /* DeBugLinker */
  789.  
  790.          outword(T_Proc);        /* type code */
  791.          outword(RkBlkSize);        /* size of block */
  792.          outword(0);            /* entry point (filled in by interp)*/
  793.          outword(gp->g_nargs);        /* number of fields */
  794.          outword(-2);            /* record constructor indicator */
  795.          outword(gp->g_procid);        /* record id */
  796.          outword(1);            /* serial number */
  797.          outword(strlen(s));        /* name of record */
  798.          outword(s - lsspace);
  799.          }
  800.       }
  801.  
  802.    /*
  803.     * Output record/field table.
  804.     */
  805.    hdr.ftab = pc;
  806.  
  807. #ifdef DeBugLinker
  808.    if (Dflag)
  809.       fprintf(dbgfile, "%ld:\t\t\t\t\t# record/field table\n", (long)pc);
  810. #endif                    /* DeBugLinker */
  811.  
  812.    for (fp = lftable; fp < lffree; fp++) {
  813.  
  814. #ifdef DeBugLinker
  815.       if (Dflag)
  816.          fprintf(dbgfile, "%ld:\n", (long)pc);
  817. #endif                    /* DeBugLinker */
  818.  
  819.       rp = fp->f_rlist;
  820.       for (i = 1; i <= nrecords; i++) {
  821.          if (rp != NULL && rp->r_recid == i) {
  822.  
  823. #ifdef DeBugLinker
  824.             if (Dflag)
  825.         fprintf(dbgfile, "\t%d\n", rp->r_fnum);
  826. #endif                    /* DeBugLinker */
  827.  
  828.             outword(rp->r_fnum);
  829.             rp = rp->r_link;
  830.             }
  831.          else {
  832.  
  833. #ifdef DeBugLinker
  834.             if (Dflag)
  835.         fprintf(dbgfile, "\t-1\n");
  836. #endif                    /* DeBugLinker */
  837.  
  838.             outword(-1);
  839.             }
  840.  
  841. #ifdef DeBugLinker
  842.          if (Dflag && (i == nrecords || (i & 03) == 0))
  843.             putc('\n', dbgfile);
  844. #endif                    /* DeBugLinker */
  845.  
  846.          }
  847.       }
  848.  
  849.    /*
  850.     * Output descriptors for field names.
  851.     */
  852.  
  853.     hdr.fnames = pc;
  854.     for (fp = lftable; fp < lffree; fp++) {
  855.        s = fp->f_name;
  856.  
  857. #ifdef DeBugLinker
  858.        if (Dflag)
  859.           fprintf(dbgfile, "%ld:\t%d\tI+%ld\t\t\t# %s\n",
  860.                (long)pc, (int)strlen(s), (long)(s-lsspace), s);
  861. #endif                    /* DeBugLinker */
  862.  
  863.        outword(strlen(s));      /* name of field */
  864.        outword(s - lsspace);
  865.      }
  866.  
  867.  
  868.    /*
  869.     * Output global variable descriptors.
  870.     */
  871.    hdr.globals = pc;
  872.    for (gp = lgtable; gp < lgfree; gp++) {
  873.       if (gp->g_flag & (F_Builtin & ~F_Global)) {    /* function */
  874.  
  875. #ifdef DeBugLinker
  876.          if (Dflag)
  877.             fprintf(dbgfile, "%ld:\t%06lo\t%d\t\t\t# %s\n",
  878.         (long)pc, (long)D_Proc, -gp->g_procid, gp->g_name);
  879. #endif                    /* DeBugLinker */
  880.  
  881.          outword(D_Proc);
  882.          outword(-gp->g_procid);
  883.          }
  884.       else if (gp->g_flag & (F_Proc & ~F_Global)) {    /* Icon procedure */
  885.  
  886. #ifdef DeBugLinker
  887.          if (Dflag)
  888.             fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n",
  889.         (long)pc,(long)D_Proc, (long)gp->g_pc, gp->g_name);
  890. #endif                    /* DeBugLinker */
  891.  
  892.          outword(D_Proc);
  893.          outword(gp->g_pc);
  894.          }
  895.       else if (gp->g_flag & (F_Record & ~F_Global)) {    /* record constructor */
  896.  
  897. #ifdef DeBugLinker
  898.          if (Dflag)
  899.             fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n",
  900.         (long)pc, (long)D_Proc, (long)gp->g_pc, gp->g_name);
  901. #endif                    /* DeBugLinker */
  902.  
  903.          outword(D_Proc);
  904.          outword(gp->g_pc);
  905.          }
  906.       else {    /* global variable */
  907.  
  908. #ifdef DeBugLinker
  909.          if (Dflag)
  910.             fprintf(dbgfile, "%ld:\t%06lo\t0\t\t\t# %s\n",(long)pc,
  911.                (long)D_Null, gp->g_name);
  912. #endif                    /* DeBugLinker */
  913.  
  914.          outword(D_Null);
  915.          outword(0);
  916.          }
  917.       }
  918.  
  919.    /*
  920.     * Output descriptors for global variable names.
  921.     */
  922.    hdr.gnames = pc;
  923.    for (gp = lgtable; gp < lgfree; gp++) {
  924.  
  925. #ifdef DeBugLinker
  926.       if (Dflag)
  927.          fprintf(dbgfile, "%ld:\t%d\tI+%ld\t\t\t# %s\n",
  928.             (long)pc, (int)strlen(gp->g_name), (long)(gp->g_name-lsspace),
  929.                gp->g_name);
  930. #endif                    /* DeBugLinker */
  931.  
  932.       outword(strlen(gp->g_name));
  933.       outword(gp->g_name - lsspace);
  934.       }
  935.  
  936.    /*
  937.     * Output a null descriptor for each static variable.
  938.     */
  939.    hdr.statics = pc;
  940.    for (i = lstatics; i > 0; i--) {
  941.  
  942. #ifdef DeBugLinker
  943.       if (Dflag)
  944.          fprintf(dbgfile, "%ld:\t0\t0\n", (long)pc);
  945. #endif                    /* DeBugLinker */
  946.  
  947.       outword(D_Null);
  948.       outword(0);
  949.       }
  950.    flushcode();
  951.  
  952.    /*
  953.     * Output the string constant table and the two tables associating icode
  954.     *  locations with source program locations.  Note that the calls to write
  955.     *  really do all the work.
  956.     */
  957.  
  958. #ifdef DeBugLinker
  959.    if (Dflag) {
  960.       for (s = lsspace; s < lsfree; ) {
  961.          fprintf(dbgfile, "%ld:\t%03o\n", (long)pc, *s++);
  962.          for (i = 7; i > 0; i--) {
  963.             if (s >= lsfree)
  964.         break;
  965.             fprintf(dbgfile, " %03o\n", *s++);
  966.             }
  967.          putc('\n', dbgfile);
  968.          }
  969.       }
  970. #endif                    /* DeBugLinker */
  971.  
  972.    hdr.filenms = pc;
  973.    pc += (char *)fnmfree - (char *)fnmtbl;
  974.    hdr.linenums = pc;
  975.    pc += (char *)lnfree - (char *)lntable;
  976.    hdr.strcons = pc;
  977.    pc += lsfree - lsspace;
  978.  
  979.    if (longwrite((char *)fnmtbl, (long)((char *)fnmfree - (char *)fnmtbl),
  980.       outfile) < 0)
  981.          quit("cannot write icode file");
  982.    if (longwrite((char *)lntable, (long)((char *)lnfree - (char *)lntable),
  983.       outfile) < 0)
  984.          quit("cannot write icode file");
  985.    if (longwrite(lsspace, (long)(lsfree - lsspace), outfile) < 0)
  986.          quit("cannot write icode file");
  987.  
  988.    /*
  989.     * Output icode file header.
  990.     */
  991.    hdr.hsize = pc;
  992.    strcpy((char *)hdr.config,IVersion);
  993.    hdr.trace = trace;
  994.  
  995.  
  996. #ifdef DeBugLinker
  997.    if (Dflag) {
  998.       fprintf(dbgfile, "size:     %ld\n", (long)hdr.hsize);
  999.       fprintf(dbgfile, "trace:     %ld\n", (long)hdr.trace);
  1000.       fprintf(dbgfile, "records: %ld\n", (long)hdr.records);
  1001.       fprintf(dbgfile, "ftab:     %ld\n", (long)hdr.ftab);
  1002.       fprintf(dbgfile, "fnames:  %ld\n", (long)hdr.fnames);
  1003.       fprintf(dbgfile, "globals: %ld\n", (long)hdr.globals);
  1004.       fprintf(dbgfile, "gnames:  %ld\n", (long)hdr.gnames);
  1005.       fprintf(dbgfile, "statics: %ld\n", (long)hdr.statics);
  1006.       fprintf(dbgfile, "strcons:   %ld\n", (long)hdr.strcons);
  1007.       fprintf(dbgfile, "filenms:   %ld\n", (long)hdr.filenms);
  1008.       fprintf(dbgfile, "linenums:   %ld\n", (long)hdr.linenums);
  1009.       fprintf(dbgfile, "config:   %s\n", hdr.config);
  1010.       }
  1011. #endif                    /* DeBugLinker */
  1012.  
  1013. #ifdef Header
  1014.    fseek(outfile, (long)MaxHeader, 0);
  1015. #else                                   /* Header */
  1016.  
  1017. #if MVS
  1018. /*
  1019.  * This kind of backpatching cannot work on a PDS member, and that's
  1020.  *  probably where the code is going.  So the code goes out first to
  1021.  *  a temporary file, and then copied to the real icode file after
  1022.  *  the header is written.
  1023.  */
  1024.    fseek(outfile, sizeof(hdr), SEEK_SET);
  1025.    toutfile = outfile;
  1026.    outfile = fopen(routname, "wb");
  1027.    if (outfile == NULL)
  1028.       quitf("cannot create %s",routname);
  1029. #else
  1030.    fseek(outfile, 0L, 0);
  1031. #endif                                  /* MVS */
  1032. #endif                                  /* Header */
  1033.  
  1034.    if (longwrite((char *)&hdr, (long)sizeof(hdr), outfile) < 0)
  1035.       quit("cannot write icode file");
  1036.  
  1037. #if MVS
  1038.    {
  1039.       char *allelse = malloc(hdr.hsize);
  1040.       if (hdr.hsize != fread(allelse, 1, hdr.hsize, toutfile) ||
  1041.           longwrite(allelse, hdr.hsize, outfile) < 0)
  1042.             quit("cannot write icode file");
  1043.       free(allelse);
  1044.       fclose(toutfile);
  1045.    }
  1046. #endif                    /* MVS */
  1047.    }
  1048.  
  1049. /*
  1050.  * intout(i) outputs i as an int that is used by the runtime system
  1051.  *  IntBits/ByteBits bytes must be moved from &word[0] to &codep[0].
  1052.  */
  1053. static novalue intout(oint)
  1054. int oint;
  1055.    {
  1056.    int i;
  1057.    union {
  1058.       int i;
  1059.       char c[IntBits/ByteBits]; 
  1060.       } u;
  1061.  
  1062.    CodeCheck(1);
  1063.    u.i = oint;
  1064.  
  1065.    for (i = 0; i < IntBits/ByteBits; i++)
  1066.       codep[i] = u.c[i];
  1067.  
  1068.    codep += IntBits/ByteBits;
  1069.    pc += IntBits/ByteBits;
  1070.    }
  1071.  
  1072. /*
  1073.  * wordout(i) outputs i as a word that is used by the runtime system
  1074.  *  WordSize bytes must be moved from &oword[0] to &codep[0].
  1075.  */
  1076. static novalue wordout(oword)
  1077. word oword;
  1078.    {
  1079.    int i;
  1080.    union {
  1081.     word i;
  1082.     char c[WordSize];
  1083.     } u;
  1084.  
  1085.    CodeCheck(1);
  1086.    u.i = oword;
  1087.  
  1088.    for (i = 0; i < WordSize; i++)
  1089.       codep[i] = u.c[i];
  1090.  
  1091.    codep += WordSize;
  1092.    pc += WordSize;
  1093.    }
  1094.  
  1095. /*
  1096.  * outblock(a,i) output i bytes starting at address a.
  1097.  */
  1098. static novalue outblock(addr,count)
  1099. char *addr;
  1100. int count;
  1101.    {
  1102.    CodeCheck(count);
  1103.    pc += count;
  1104.    while (count--)
  1105.       *codep++ = *addr++;
  1106.    }
  1107.  
  1108. #ifdef DeBugLinker
  1109. /*
  1110.  * dumpblock(a,i) dump contents of i bytes at address a, used only
  1111.  *  in conjunction with -L.
  1112.  */
  1113. static novalue dumpblock(addr, count)
  1114. char *addr;
  1115. int count;
  1116.    {
  1117.    int i;
  1118.    for (i = 0; i < count; i++) {
  1119.       if ((i & 7) == 0)
  1120.          fprintf(dbgfile,"\n\t");
  1121.       fprintf(dbgfile," %03o\n",(0377 & (unsigned)addr[i]));
  1122.       }
  1123.    putc('\n',dbgfile);
  1124.    }
  1125. #endif                    /* DeBugLinker */
  1126.  
  1127. /*
  1128.  * flushcode - write buffered code to the output file.
  1129.  */
  1130. static novalue flushcode()
  1131.    {
  1132.    if (codep > codeb)
  1133.       if (longwrite(codeb, (long)codep - (long)codeb, outfile) < 0)
  1134.          quit("cannot write icode file");
  1135.    codep = codeb;
  1136.    }
  1137.  
  1138. /*
  1139.  * clearlab - clear label table to all zeroes.
  1140.  */
  1141. static novalue clearlab()
  1142.    {
  1143.    register int i;
  1144.  
  1145.    for (i = 0; i < maxlabels; i++)
  1146.       labels[i] = 0;
  1147.    }
  1148.  
  1149. /*
  1150.  * backpatch - fill in all forward references to lab.
  1151.  */
  1152. static novalue backpatch(lab)
  1153. int lab;
  1154.    {
  1155.    word p, r;
  1156.    char *q;
  1157.    char *cp, *cr;
  1158.    register int j;
  1159.  
  1160.    if (lab >= maxlabels)
  1161.       quit("out of label space");
  1162.  
  1163.    p = labels[lab];
  1164.    if (p > 0)
  1165.       quit("multiply defined label in ucode");
  1166.    while (p < 0) {        /* follow reference chain */
  1167.       r = pc - (WordSize - p);    /* compute relative offset */
  1168.       q = codep - (pc + p);    /* point to word with address */
  1169.       cp = (char *) &p;        /* address of integer p       */
  1170.       cr = (char *) &r;        /* address of integer r       */
  1171.       for (j = 0; j < WordSize; j++) {      /* move bytes from word pointed to */
  1172.          *cp++ = *q;              /* by q to p, and move bytes from */
  1173.          *q++ = *cr++;              /* r to word pointed to by q */
  1174.          }            /* moves integers at arbitrary addresses */
  1175.       }
  1176.    labels[lab] = pc;
  1177.    }
  1178.  
  1179. #ifdef DeBugLinker
  1180. novalue idump(s)        /* dump code region */
  1181.    char *s;
  1182.    {
  1183.    int *c;
  1184.  
  1185.    fprintf(stderr,"\ndump of code region %s:\n",s);
  1186.    for (c = (int *)codeb; c < (int *)codep; c++)
  1187.        fprintf(stderr,"%ld: %d\n",(long)c, (int)*c);
  1188.    fflush(stderr);
  1189.    }
  1190. #endif                    /* DeBugLinker */
  1191.